home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / dispcond.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  78 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4.  
  5. ; Displaying conditions
  6.  
  7. (define display-condition
  8.   (let ((display display) (newline newline))
  9.     (lambda (c port)
  10.       (if (ignore-errors (lambda ()
  11.                (newline port)
  12.                (really-display-condition c port)
  13.                #f))
  14.       (begin (display "<Error while displaying condition.>" port)
  15.          (newline port))))))
  16.  
  17. (define (really-display-condition c port)
  18.   (let* ((stuff (disclose-condition c))
  19.      (stuff (if (and (list? stuff)
  20.              (not (null? stuff))
  21.              (symbol? (car stuff)))
  22.             stuff
  23.             (list 'condition stuff))))
  24.     (display-type-name (car stuff) port)
  25.     (if (not (null? (cdr stuff)))
  26.     (begin (display ": " port)
  27.            (let ((message (cadr stuff)))
  28.          (if (string? message)
  29.              (display message port)
  30.              (limited-write message port *depth* *length*)))
  31.            (let ((spaces
  32.               (make-string (+ (string-length
  33.                        (symbol->string (car stuff)))
  34.                       2)
  35.                    #\space)))
  36.          (for-each (lambda (irritant)
  37.                  (newline port)
  38.                  (display spaces port)
  39.                  (limited-write irritant port *depth* *length*))
  40.                (cddr stuff)))))
  41.     (newline port)))
  42.  
  43. (define *depth* 5)
  44. (define *length* 6)
  45.  
  46. (define-generic disclose-condition &disclose-condition)
  47.  
  48. (define-method &disclose-condition (c) c)
  49.  
  50.  
  51.  
  52. (define (limited-write obj port max-depth max-length)
  53.   (let recur ((obj obj) (depth 0))
  54.     (if (and (= depth max-depth)
  55.          (not (or (boolean? obj)
  56.               (null? obj)
  57.               (number? obj)
  58.               (symbol? obj)
  59.               (char? obj)
  60.               (string? obj))))
  61.     (display "#" port)
  62.     (call-with-current-continuation
  63.       (lambda (escape)
  64.         (recurring-write obj port
  65.           (let ((count 0))
  66.         (lambda (sub)
  67.           (if (= count max-length)
  68.               (begin (display "---" port)
  69.                  (write-char
  70.                   (if (or (pair? obj) (vector? obj))
  71.                   #\)
  72.                   #\})
  73.                   port)
  74.                  (escape #t))
  75.               (begin (set! count (+ count 1))
  76.                  (recur sub (+ depth 1))))))))))))
  77.  
  78.